Usenet 1993 July

home *** CD-ROM | disk | FTP | other *** search

/ Usenet 1993 July / InfoMagic USENET CD-ROM July 1993.ISO / sources / misc / volume13 / gmcalc / part02 < prev next >

Wrap

Text File | 1990-06-05 | 57.0 KB | 1,944 lines

Newsgroups: comp.sources.misc From: daveg@csvax.caltech.edu (David Gillespie) Subject: v13i028: Emacs Calculator 1.01, part 02/19 Sender: allbery@uunet.UU.NET (Brandon S. Allbery - comp.sources.misc) Posting-number: Volume 13, Issue 28 Submitted-by: daveg@csvax.caltech.edu (David Gillespie) Archive-name: gmcalc/part02 ---- Cut Here and unpack ---- #!/bin/sh # this is part 2 of a multipart archive # do not concatenate these parts, unpack them in order with /bin/sh # file calc.el continued # CurArch=2 if test ! -r s2_seq_.tmp then echo "Please unpack part 1 first!" exit 1; fi ( read Scheck if test "$Scheck" != $CurArch then echo "Please unpack part $Scheck next!" exit 1; else exit 0; fi ) < s2_seq_.tmp || exit 1 echo "x - Continuing file calc.el" sed 's/^X//' << 'SHAR_EOF' >> calc.el X) X X(defun calc-record (val &optional prefix) X (or calc-executing-macro X (let* ((mainbuf (current-buffer)) X (buf (get-buffer-create "*Calc Trail*")) X (calc-display-raw (eq calc-display-raw t)) X (fval (if val X (if (stringp val) X val X (math-showing-full-precision X (math-format-flat-expr val 0))) X ""))) X (save-excursion X (set-buffer buf) X (if (not (eq major-mode 'calc-trail-mode)) X (calc-trail-mode mainbuf)) X (let ((aligned (calc-check-trail-aligned)) X (buffer-read-only nil)) X (goto-char (point-max)) X (cond ((null prefix) (insert " ")) X ((> (length prefix) 5) (insert (substring prefix 0 5) " ")) X (t (insert (format "%4s " prefix)))) X (insert fval "\n") X (let ((win (get-buffer-window buf))) X (if (and aligned win (not (memq 'hold-trail calc-command-flags))) X (progn X (calc-trail-here)))) X (goto-char (1- (point-max))))))) X val X) X X(defun calc-record-list (vals &optional prefix) X (while vals X (or (eq (car vals) 'top-of-stack) X (progn X (calc-record (car vals) prefix) X (setq prefix "..."))) X (setq vals (cdr vals))) X) X X(defun calc-trail-display (flag &optional no-refresh) X "Turn the Trail display on or off. XWith prefix argument 1, turn it on; with argument 0, turn it off." X (interactive "P") X (let* ((trail (get-buffer-create "*Calc Trail*")) X (win (get-buffer-window trail))) X (if (setq calc-display-trail X (not (if flag (memq flag '(nil 0)) win))) X (if (null win) X (progn X (if (and (boundp 'calc-trail-window-hook) calc-trail-window-hook) X (run-hooks 'calc-trail-window-hook) X (let ((w (split-window nil (/ (* (window-width) 2) 3) t))) X (set-window-buffer w trail))) X (calc-wrapper X (or no-refresh X (calc-refresh))))) X (if win X (progn X (delete-window win) X (calc-wrapper X (or no-refresh X (calc-refresh))))) X (if (and (boundp 'overlay-arrow-position) X (eq overlay-arrow-position calc-trail-pointer)) X (setq overlay-arrow-position nil))) X trail) X) X X(defun calc-trail-here () X "Move the trail pointer to the current cursor line." X (interactive) X (if (eq major-mode 'calc-trail-mode) X (progn X (beginning-of-line) X (if (bobp) X (forward-line 1) X (if (eobp) X (forward-line -1))) X (if (or (bobp) (eobp)) X (setq overlay-arrow-position nil) ; trail is empty X (set-marker calc-trail-pointer (point) (current-buffer)) X (setq overlay-arrow-string (concat (buffer-substring (point) X (+ (point) 4)) X ">") X overlay-arrow-position calc-trail-pointer) X (forward-char 4) X (let ((win (get-buffer-window (current-buffer)))) X (if win X (save-excursion X (forward-line (/ (window-height) 2)) X (forward-line (- 1 (window-height))) X (set-window-start win (point)) X (set-window-point win (+ calc-trail-pointer 4))))))) X (error "Not in Calc Trail buffer")) X) X X X X X;;;; The Undo list. X X(defun calc-record-undo (rec) X (or calc-executing-macro X (if (memq 'undo calc-command-flags) X (setq calc-undo-list (cons (cons rec (car calc-undo-list)) X (cdr calc-undo-list))) X (setq calc-undo-list (cons (list rec) calc-undo-list) X calc-redo-list nil) X (calc-set-command-flag 'undo))) X) X X X X;;; Arithmetic commands. X X(defun calc-binary-op (name func arg &optional ident unary) X (if (null arg) X (calc-enter-result 2 name (cons func (calc-top-list-n 2))) X (calc-extensions) X (calc-binary-op-fancy name func arg ident unary)) X) X X(defun calc-unary-op (name func arg) X (if (null arg) X (calc-enter-result 1 name (list func (calc-top-n 1))) X (calc-extensions) X (calc-unary-op-fancy name func arg)) X) X X X(defun calc-plus (arg) X "Add the top two elements of the Calculator stack." X (interactive "P") X (calc-slow-wrapper X (calc-binary-op "+" 'calcFunc-add arg 0)) X) X X(defun calc-minus (arg) X "Subtract the top two elements of the Calculator stack." X (interactive "P") X (calc-slow-wrapper X (calc-binary-op "-" 'calcFunc-sub arg 0 'calcFunc-neg)) X) X X(defun calc-times (arg) X "Multiply the top two elements of the Calculator stack." X (interactive "P") X (calc-slow-wrapper X (calc-binary-op "*" 'calcFunc-mul arg 1)) X) X X(defun calc-divide (arg) X "Divide the top two elements of the Calculator stack." X (interactive "P") X (calc-slow-wrapper X (calc-binary-op "/" 'calcFunc-div arg 0 'calcFunc-inv)) X) X X(defun calc-power (arg) X "Compute y^x for the top two elements of the Calculator stack." X (interactive "P") X (calc-slow-wrapper X (calc-binary-op "^" 'calcFunc-pow arg)) X) X X(defun calc-mod (arg) X "Compute the modulo of the top two elements of the Calculator stack." X (interactive "P") X (calc-slow-wrapper X (calc-binary-op "%" 'calcFunc-mod arg)) X) X X(defun calc-inv (arg) X "Invert the number or square matrix on the top of the stack." X (interactive "P") X (calc-slow-wrapper X (calc-unary-op "inv" 'calcFunc-inv arg)) X) X X(defun calc-change-sign (arg) X "Change the sign of the top element of the Calculator stack." X (interactive "P") X (calc-wrapper X (calc-unary-op "chs" 'calcFunc-neg arg)) X) X X X X;;; Stack management commands. X X(defun calc-enter (n) X "Duplicate the top N elements of the Calculator stack. XWith a negative argument -N, duplicate the Nth element of the stack." X (interactive "p") X (calc-wrapper X (cond ((< n 0) X (calc-push (calc-top (- n)))) X ((= n 0) X (calc-push-list (calc-top-list (calc-stack-size)))) X (t X (calc-push-list (calc-top-list n))))) X) X X(defun calc-over (n) X "Duplicate the Nth element of the Calculator stack. XWith a negative argument -N, duplicate the top N elements of the stack." X (interactive "P") X (if n X (calc-enter (- (prefix-numeric-value n))) X (calc-enter -2)) X) X X(defun calc-pop (n) X "Pop (and discard) the top N elements of the stack. XWith a negative argument -N, remove the Nth element from the stack." X (interactive "P") X (calc-wrapper X (let* ((nn (prefix-numeric-value n)) X (top (and (null n) (calc-top 1)))) X (cond ((and (null n) X (eq (car-safe top) 'incomplete) X (> (length top) (if (eq (nth 1 top) 'intv) 3 2))) X (calc-pop-push 1 (let ((tt (copy-sequence top))) X (setcdr (nthcdr (- (length tt) 2) tt) nil) X tt))) X ((< nn 0) X (calc-pop-stack 1 (- nn))) X ((= nn 0) X (calc-pop-stack (calc-stack-size))) X (t X (calc-pop-stack nn))))) X) X X(defun calc-roll-down (n) X "Exchange the top two elements of the Calculator stack. XWith a numeric prefix, roll down the top N elements." X (interactive "P") X (calc-wrapper X (let ((nn (prefix-numeric-value n))) X (cond ((null n) X (calc-roll-down-stack 2)) X ((> nn 0) X (calc-roll-down-stack nn)) X ((= nn 0) X (calc-pop-push-list (calc-stack-size) X (reverse X (calc-top-list (calc-stack-size))))) X (t X (calc-roll-down-stack (calc-stack-size) (- nn)))))) X) X X(defun calc-roll-up (n) X "Roll up the top three elements of the Calculator stack. XWith a numeric prefix, roll up the top N elements." X (interactive "P") X (calc-wrapper X (let ((nn (prefix-numeric-value n))) X (cond ((null n) X (calc-roll-up-stack 3)) X ((> nn 0) X (calc-roll-up-stack nn)) X ((= nn 0) X (calc-pop-push-list (calc-stack-size) X (reverse X (calc-top-list (calc-stack-size))))) X (t X (calc-roll-up-stack (calc-stack-size) (- nn)))))) X) X X X X X;;; Miscellaneous commands. X X(defun calc-precision (n) X "Display current float precision for Calculator, or set precision to N digits." X (interactive "NPrecision: ") X (calc-wrapper X (if (< (prefix-numeric-value n) 3) X (error "Precision must be at least 3 digits.") X (setq calc-internal-prec (prefix-numeric-value n)) X (calc-record calc-internal-prec "prec")) X (message "Floating-point precision is %d digits." calc-internal-prec)) X) X X X(defun calc-num-prefix-name (n) X (cond ((eq n '-) "- ") X ((equal n '(4)) "C-u ") X ((consp n) (format "%d " (car n))) X ((integerp n) (format "%d " n)) X (t "")) X) X X(defun calc-missing-key (n) X "This is a placeholder for a command which needs to be loaded from calc-ext. XWhen this key is used, calc-ext (the Calculator extensions module) will be Xloaded and the keystroke automatically re-typed." X (interactive "P") X (calc-extensions) X (if (keymapp (key-binding (char-to-string last-command-char))) X (message "%s%c-" (calc-num-prefix-name n) last-command-char)) X (setq unread-command-char last-command-char X prefix-arg n) X) X X(defun calc-why () X "Explain why the last result was unusual." X (interactive) X (if (not (eq this-command last-command)) X (setq calc-which-why calc-why)) X (if calc-which-why X (progn X (calc-explain-why (car calc-which-why)) X (setq calc-which-why (cdr calc-which-why))) X (if calc-why X (progn X (message "(No further explanations available)") X (setq calc-which-why calc-why)) X (message "No explanations available"))) X) X(setq calc-which-why nil) X X(defun calc-flush-caches () X "Clear all caches used internally by the Calculator, such as the values of Xpi and e. These values will be recomputed next time they are requested." X (interactive) X (calc-wrapper X (setq math-lud-cache nil X math-log2-cache nil X math-max-digits-cache nil X math-integral-cache nil X math-units-table nil) X (mapcar (function (lambda (x) (set x -100))) math-cache-list) X (message "All internal calculator caches have been reset.")) X) X(setq math-cache-list nil) X X X X;;;; Reading an expression in algebraic form. X X(defun calc-algebraic-entry () X "Read an algebraic expression (e.g., 1+2*3) and push the result on the stack." X (interactive) X (calc-wrapper X (calc-alg-entry)) X) X X(defun calc-auto-alg-entry () X "Begin entering an algebraic expression with a '$' or '\"' character." X (interactive) X (calc-wrapper X (calc-alg-entry (char-to-string last-command-char))) X) X X(defun calc-alg-entry (&optional initial prompt) X (let* ((calc-dollar-values (mapcar 'car-safe X (nthcdr calc-stack-top calc-stack))) X (calc-dollar-used 0) X (alg-exp (calc-do-alg-entry initial prompt t))) X (let ((nvals (mapcar 'calc-normalize alg-exp))) X (while alg-exp X (calc-record (car alg-exp) "alg'") X (calc-pop-push-record calc-dollar-used "" (car nvals)) X (setq alg-exp (cdr alg-exp) X nvals (cdr nvals) X calc-dollar-used 0))) X (calc-handle-whys)) X) X X(defun calc-do-alg-entry (&optional initial prompt no-normalize) X (let* ((alg-exp 'error) X (alg (read-from-minibuffer (or prompt "Algebraic: ") X (or initial "") X calc-alg-ent-map nil))) X (if (eq alg-exp 'error) X (if (eq (car (setq alg-exp (math-read-exprs alg))) X 'error) X (error "Error: %s" (or (nth 2 exp) "Bad format")))) X (or no-normalize X (setq alg-exp (mapcar 'calc-normalize alg-exp))) X alg-exp) X) X X(defvar calc-alg-ent-map nil "Keymap for use by the calc-algebraic-entry command.") X(if calc-alg-ent-map X () X (setq calc-alg-ent-map (copy-keymap minibuffer-local-map)) X (define-key calc-alg-ent-map "'" 'calcAlg-previous) X (define-key calc-alg-ent-map "\ep" 'calcAlg-plus-minus) X (define-key calc-alg-ent-map "\em" 'calcAlg-mod) X (define-key calc-alg-ent-map "\C-m" 'calcAlg-enter) X (define-key calc-alg-ent-map "\C-j" 'calcAlg-enter) X) X X(defun calcAlg-plus-minus () X (interactive) X (if (calc-minibuffer-contains ".* \\'") X (insert "+/- ") X (insert " +/- ")) X) X X(defun calcAlg-mod () X (interactive) X (if (not (calc-minibuffer-contains ".* \\'")) X (insert " ")) X (if (calc-minibuffer-contains ".* mod +\\'") X (if calc-previous-modulo X (insert (math-format-flat-expr calc-previous-modulo 0)) X (beep)) X (insert "mod ")) X) X X(defun calcAlg-previous () X (interactive) X (if (calc-minibuffer-contains "\\`\\'") X (if calc-previous-alg-entry X (insert calc-previous-alg-entry) X (beep)) X (insert "'")) X) X X(defun calcAlg-enter () X (interactive) X (let ((exp (and (> (buffer-size) 0) X (math-read-exprs (buffer-string))))) X (if (eq (car-safe exp) 'error) X (progn X (goto-char (point-min)) X (forward-char (nth 1 exp)) X (beep) X (calc-temp-minibuffer-message X (concat " [" (or (nth 2 exp) "Error") "]")) X (setq unread-command-char -1)) X (setq alg-exp (if (calc-minibuffer-contains "\\` *\\[ *\\'") X '((incomplete vec)) X exp) X calc-previous-alg-entry (buffer-string)) X (exit-minibuffer))) X) X X X X;;;; Reading a number using the minibuffer. X X(defun calcDigit-start () X "Begin digit entry in the Calculator." X (interactive) X (calc-wrapper X (if calc-algebraic-mode X (cond ((eq last-command-char ?e) (calc-alg-entry "1e")) X ((eq last-command-char ?#) (calc-alg-entry X (format "%d#" calc-number-radix))) X ((eq last-command-char ?_) (calc-alg-entry "-")) X ((eq last-command-char ?@) (calc-alg-entry "0@ ")) X (t (calc-alg-entry (char-to-string last-command-char)))) X (let ((calc-digit-value 'yow) X (calc-prev-char nil) X (calc-prev-prev-char nil)) X (setq unread-command-char last-command-char) X (let ((str (read-from-minibuffer "Calc: " "" X calc-digit-map))) X (if (eq calc-digit-value 'yow) X (setq calc-digit-value (math-read-number str)))) X (if (stringp calc-digit-value) X (calc-alg-entry calc-digit-value) X (if calc-digit-value X (calc-push (calc-record (calc-normalize calc-digit-value))))) X (if (eq calc-prev-char 'dots) X (progn X (calc-extensions) X (calc-dots)))))) X) X X(defun calcDigit-nondigit () X (interactive) X (setq calc-digit-value (math-read-number (buffer-string))) X (if (and (null calc-digit-value) (> (buffer-size) 0)) X (progn X (beep) X (calc-temp-minibuffer-message " [Bad format]")) X (or (memq last-command-char '(32 10 13)) X (setq prefix-arg current-prefix-arg X unread-command-char last-command-char)) X (exit-minibuffer)) X) X X(defun calcDigit-algebraic () X (interactive) X (if (calc-minibuffer-contains ".*[@oh] *[^'m ]+[^'m]*\\'") X (calcDigit-key) X (setq calc-digit-value (buffer-string)) X (exit-minibuffer)) X) X X(defun calc-minibuffer-contains (rex) X (save-excursion X (goto-char (point-min)) X (looking-at rex)) X) X X(defun calcDigit-key () X (interactive) X (goto-char (point-max)) X (if (or (and (memq last-command-char '(?+ ?-)) X (> (buffer-size) 0) X (/= (preceding-char) ?e)) X (and (memq last-command-char '(?m ?s)) X (not (calc-minibuffer-contains "[-+]?[0-9]+\\.?0*[@oh].*")) X (not (calc-minibuffer-contains "[-+]?\$1[1-9]\\|[2-9][0-9]\$#.*")))) X (calcDigit-nondigit) X (if (calc-minibuffer-contains "\$[-+]?\\|.* \$\\'") X (cond ((memq last-command-char '(?. ?@)) (insert "0")) X ((and (memq last-command-char '(?o ?h ?m)) X (not (calc-minibuffer-contains ".*#.*"))) (insert "0")) X ((memq last-command-char '(?: ?e)) (insert "1")) X ((eq last-command-char ?#) X (insert (int-to-string calc-number-radix))))) X (if (and (calc-minibuffer-contains "\$[-+]?[0-9]+#\\|[^:]*:\$\\'") X (eq last-command-char ?:)) X (insert "1")) X (if (or (and (memq last-command-char '(?e ?h ?o ?m ?s ?p)) X (calc-minibuffer-contains ".*#.*")) X (and (eq last-command-char ?n) X (calc-minibuffer-contains "[-+]?\$2[4-9]\\|[3-9][0-9]\$#.*"))) X (setq last-command-char (upcase last-command-char))) X (cond X ((memq last-command-char '(?_ ?n)) X (goto-char (point-min)) X (if (and (search-forward " +/- " nil t) X (not (search-forward "e" nil t))) X (beep) X (and (not (calc-minibuffer-contains ".*#.*")) X (search-forward "e" nil t)) X (if (looking-at "+") X (delete-char 1)) X (if (looking-at "-") X (delete-char 1) X (insert "-"))) X (goto-char (point-max))) X ((eq last-command-char ?p) X (if (or (calc-minibuffer-contains ".*\\+/-.*") X (calc-minibuffer-contains ".*mod.*") X (calc-minibuffer-contains ".*#.*") X (calc-minibuffer-contains ".*[-+e:]\\'")) X (beep) X (if (not (calc-minibuffer-contains ".* \\'")) X (insert " ")) X (insert "+/- "))) X ((and (eq last-command-char ?M) X (not (calc-minibuffer-contains X "[-+]?\$2[3-9]\\|[3-9][0-9]\$#.*"))) X (if (or (calc-minibuffer-contains ".*\\+/-.*") X (calc-minibuffer-contains ".*mod *[^ ]+") X (calc-minibuffer-contains ".*[-+e:]\\'")) X (beep) X (if (calc-minibuffer-contains ".*mod \\'") X (if calc-previous-modulo X (insert (math-format-flat-expr calc-previous-modulo 0)) X (beep)) X (if (not (calc-minibuffer-contains ".* \\'")) X (insert " ")) X (insert "mod ")))) X (t X (insert (char-to-string last-command-char)) X (if (or (and (calc-minibuffer-contains "[-+]?\$.*\\+/- *\\|.*mod *\$?\$[0-9][0-9]?\$#[0-9a-zA-Z]*\$:[0-9a-zA-Z]*\$?\$:[0-9a-zA-Z]*\$?\\'") X (let ((radix (string-to-int X (buffer-substring X (match-beginning 2) (match-end 2))))) X (and (>= radix 2) X (<= radix 36) X (or (memq last-command-char '(?# ?:)) X (let ((dig (math-read-radix-digit X (upcase last-command-char)))) X (and dig X (< dig radix))))))) X (save-excursion X (goto-char (point-min)) X (looking-at X "[-+]?\$.*\\+/- *\\|.*mod *\$?\$[0-9]+\\.?0*[@oh] *\$?\$[0-9]+\\.?0*['m] *\$?[0-9]*\$\\.?[0-9]*\\(e[-+]?[0-9]*\$?\\|[0-9]:\$[0-9]+:\$?[0-9]*\\)?[\"s]?\\'"))) X (if (and (memq last-command-char '(?@ ?o ?h ?\' ?m)) X (string-match " " calc-hms-format)) X (insert " ")) X (if (and (eq this-command last-command) X (eq last-command-char ?.)) X (if (eq calc-prev-char ?.) X (progn X (delete-backward-char 1) X (if (calc-minibuffer-contains ".*\\.\\'") X (delete-backward-char 1)) X (setq calc-prev-char 'dots X last-command-char 32) X (if calc-prev-prev-char X (calcDigit-nondigit) X (setq calc-digit-value nil) X (exit-minibuffer))) X ;; just ignore extra decimal point, anticipating ".." X (delete-backward-char 1)) X (delete-backward-char 1) X (beep) X (calc-temp-minibuffer-message " [Bad format]")))))) X (setq calc-prev-prev-char calc-prev-char X calc-prev-char last-command-char) X) X X(defun calcDigit-letter () X (interactive) X (if (calc-minibuffer-contains "[-+]?\$1[1-9]\\|[2-9][0-9]\$#.*") X (progn X (setq last-command-char (upcase last-command-char)) X (calcDigit-key)) X (calcDigit-nondigit)) X) X X(defun calcDigit-backspace () X (interactive) X (goto-char (point-max)) X (cond ((calc-minibuffer-contains ".* \\+/- \\'") X (backward-delete-char 5)) X ((calc-minibuffer-contains ".* mod \\'") X (backward-delete-char 5)) X ((calc-minibuffer-contains ".* \\'") X (backward-delete-char 2)) X (t (backward-delete-char 1))) X (if (= (buffer-size) 0) X (progn X (setq last-command-char 10) X (calcDigit-nondigit))) X) X X(defun calc-temp-minibuffer-message (m) X "A Lisp version of temp_minibuffer_message from minibuf.c." X (let ((savemax (point-max))) X (save-excursion X (goto-char (point-max)) X (insert m)) X (let ((inhibit-quit t)) X (sit-for 2) X (delete-region savemax (point-max)) X (if quit-flag X (setq quit-flag nil X unread-command-char 7)))) X) X X X X X X X X;;;; Arithmetic routines. X;;; X;;; An object as manipulated by one of these routines may take any of the X;;; following forms: X;;; X;;; integer An integer. For normalized numbers, this format X;;; is used only for -999999 ... 999999. X;;; X;;; (bigpos N0 N1 N2 ...) A big positive integer, N0 + N1*1000 + N2*10^6 ... X;;; (bigneg N0 N1 N2 ...) A big negative integer, - N0 - N1*1000 ... X;;; Each digit N is in the range 0 ... 999. X;;; Normalized, always at least three N present, X;;; and the most significant N is nonzero. X;;; X;;; (frac NUM DEN) A fraction. NUM and DEN are small or big integers. X;;; Normalized, DEN > 1. X;;; X;;; (float NUM EXP) A floating-point number, NUM * 10^EXP; X;;; NUM is a small or big integer, EXP is a small int. X;;; Normalized, NUM is not a multiple of 10, and X;;; abs(NUM) < 10^calc-internal-prec. X;;; Normalized zero is stored as (float 0 0). X;;; X;;; (cplx REAL IMAG) A complex number; REAL and IMAG are any of above. X;;; Normalized, IMAG is nonzero. X;;; X;;; (polar R THETA) Polar complex number. Normalized, R > 0 and THETA X;;; is neither zero nor 180 degrees (pi radians). X;;; X;;; (vec A B C ...) Vector of objects A, B, C, ... A matrix is a X;;; vector of vectors. X;;; X;;; (hms H M S) Angle in hours-minutes-seconds form. All three X;;; components have the same sign; H and M must be X;;; numerically integers; M and S are expected to X;;; lie in the range [0,60). X;;; X;;; (sdev X SIGMA) Error form, X +/- SIGMA. When normalized, X;;; SIGMA > 0. X and SIGMA are any real numbers, X;;; or symbolic expressions which are assumed real. X;;; X;;; (intv MASK LO HI) Interval form. MASK is 0=(), 1=(], 2=[), or 3=[]. X;;; LO and HI are any real numbers, or symbolic X;;; expressions which are assumed real, and LO < HI. X;;; For [LO..HI], if LO = HI normalization produces LO, X;;; and if LO > HI normalization produces [LO..LO). X;;; For other intervals, if LO > HI normalization X;;; sets HI equal to LO. X;;; X;;; (mod N M) Number modulo M. When normalized, 0 <= N < M. X;;; N and M are real numbers. X;;; X;;; (var V S) Symbolic variable. V is a Lisp symbol which X;;; represents the variable's visible name. S is X;;; the symbol which actually stores the variable's X;;; value: (var pi var-pi). X;;; X;;; In general, combining rational numbers in a calculation always produces X;;; a rational result, but if either argument is a float, result is a float. X X;;; In the following comments, [x y z] means result is x, args must be y, z, X;;; respectively, where the code letters are: X;;; X;;; O Normalized object (vector or number) X;;; V Normalized vector X;;; N Normalized number of any type X;;; N Normalized complex number X;;; R Normalized real number (float or rational) X;;; F Normalized floating-point number X;;; T Normalized rational number X;;; I Normalized integer X;;; B Normalized big integer X;;; S Normalized small integer X;;; D Digit (small integer, 0..999) X;;; L Normalized bignum digit list (without "bigpos" or "bigneg" symbol) X;;; or normalized vector element list (without "vec") X;;; P Predicate (truth value) X;;; X Any Lisp object X;;; Z "nil" X;;; X;;; Lower-case letters signify possibly un-normalized values. X;;; "L.D" means a cons of an L and a D. X;;; [N N; n n] means result will be normalized if argument is. X;;; Also, [Public] marks routines intended to be called from outside. X;;; [This notation has been neglected in many recent routines.] X X;;; Reduce an object to canonical (normalized) form. [O o; Z Z] [Public] X(defun math-normalize (a) X (cond X ((not (consp a)) X (if (integerp a) X (if (or (>= a 1000000) (<= a -1000000)) X (math-bignum a) X a) X a)) X ((eq (car a) 'bigpos) X (if (eq (nth (1- (length a)) a) 0) X (let* ((last (setq a (copy-sequence a))) (digs a)) X (while (setq digs (cdr digs)) X (or (eq (car digs) 0) (setq last digs))) X (setcdr last nil))) X (if (cdr (cdr (cdr a))) X a X (cond X ((cdr (cdr a)) (+ (nth 1 a) (* (nth 2 a) 1000))) X ((cdr a) (nth 1 a)) X (t 0)))) X ((eq (car a) 'bigneg) X (if (eq (nth (1- (length a)) a) 0) X (let* ((last (setq a (copy-sequence a))) (digs a)) X (while (setq digs (cdr digs)) X (or (eq (car digs) 0) (setq last digs))) X (setcdr last nil))) X (if (cdr (cdr (cdr a))) X a X (cond X ((cdr (cdr a)) (- (+ (nth 1 a) (* (nth 2 a) 1000)))) X ((cdr a) (- (nth 1 a))) X (t 0)))) X ((eq (car a) 'frac) X (math-make-frac (math-normalize (nth 1 a)) X (math-normalize (nth 2 a)))) X ((eq (car a) 'float) X (math-make-float (math-normalize (nth 1 a)) (nth 2 a))) X ((eq (car a) 'cplx) X (let ((real (math-normalize (nth 1 a))) X (imag (math-normalize (nth 2 a)))) X (if (math-zerop imag) real (list 'cplx real imag)))) X ((eq (car a) 'polar) X (calc-extensions) X (math-normalize-polar a)) X ((eq (car a) 'hms) X (calc-extensions) X (math-normalize-hms a)) X ((eq (car a) 'mod) X (calc-extensions) X (math-normalize-mod a)) X ((eq (car a) 'sdev) X (calc-extensions) X (math-make-sdev (math-normalize (nth 1 a)) X (math-normalize (nth 2 a)))) X ((eq (car a) 'intv) X (calc-extensions) X (math-make-intv (nth 1 a) X (math-normalize (nth 2 a)) X (math-normalize (nth 3 a)))) X ((eq (car a) 'vec) X (cons 'vec (mapcar 'math-normalize (cdr a)))) X ((memq (car a) '(quote special-const)) X (math-normalize (nth 1 a))) X ((eq (car a) 'var) X a) X ((or (integerp (car a)) (and (consp (car a)) X (not (eq (car (car a)) 'lambda)))) X (if (null (cdr a)) X (math-normalize (car a)) X (error "Can't use multi-valued function in an expression"))) X ((eq (car a) 'calcFunc-if) X (calc-extensions) X (math-normalize-logical-op a)) X (t X (let ((args (mapcar 'math-normalize (cdr a)))) X (or (and calc-simplify-mode X (symbolp (car a)) X (or (eq calc-simplify-mode 'none) X (and (eq calc-simplify-mode 'num) X (let ((aptr args)) X (while (and aptr (or (math-scalarp (car aptr)) X (eq (car-safe (car aptr)) X 'mod))) X (setq aptr (cdr aptr))) X aptr))) X (cons (car a) args)) X (condition-case err X (let ((func (assq (car a) '( ( + . math-add ) X ( - . math-sub ) X ( * . math-mul ) X ( / . math-div ) X ( % . math-mod ) X ( ^ . math-pow ) X ( neg . math-neg ) X ( | . math-concat ) )))) X (if func X (apply (cdr func) args) X (and (or (consp (car a)) X (fboundp (car a)) X (and (not calc-extensions-loaded) X (calc-extensions) X (fboundp (car a)))) X (apply (car a) args)))) X (wrong-number-of-arguments X (calc-record-why "Wrong number of arguments") nil) X (wrong-type-argument X (or calc-next-why (calc-record-why "Wrong type of argument")) X nil) X (args-out-of-range X (calc-record-why "Argument out of range") nil) X (inexact-result X (calc-record-why "No exact representation for result") nil)) X (if (consp (car a)) X (math-dimension-error) X (cons (car a) args)))))) X) X X(defmacro math-with-extra-prec (delta &rest body) X (` (math-normalize X (let ((calc-internal-prec (+ calc-internal-prec (, delta)))) X (,@ body)))) X) X(put 'math-with-extra-prec 'lisp-indent-hook 1) X X;;; Define "inexact-result" as an e-lisp error symbol. X(put 'inexact-result 'error-conditions '(error inexact-result calc-error)) X(put 'inexact-result 'error-message "Calc internal error (inexact-result)") X X;;; Normalize a bignum digit list by trimming high-end zeros. [L l] X(defun math-norm-bignum (a) X (let ((digs a) (last nil)) X (while digs X (or (eq (car digs) 0) (setq last digs)) X (setq digs (cdr digs))) X (and last X (progn X (setcdr last nil) X a))) X) X X X;;; Concatenate two vectors, or a vector and an object. [V O O] [Public] X(defun math-concat (v1 v2) X (if (stringp v1) X (concat v1 v2) X (calc-extensions) X (if (and (math-objvecp v1) (math-objvecp v2)) X (append (if (and (math-vectorp v1) X (or (math-matrixp v1) X (not (math-matrixp v2)))) X v1 X (list 'vec v1)) X (if (and (math-vectorp v2) X (or (math-matrixp v2) X (not (math-matrixp v1)))) X (cdr v2) X (list v2))) X (list '| v1 v2))) X) X(defun calcFunc-vconcat (a b) X (math-normalize (list '| a b)) X) X X X;;; True if A is zero. Works for un-normalized values. [P n] [Public] X(defun math-zerop (a) X (if (consp a) X (cond ((memq (car a) '(bigpos bigneg)) X (while (eq (car (setq a (cdr a))) 0)) X (null a)) X ((memq (car a) '(frac float polar mod)) X (math-zerop (nth 1 a))) X ((eq (car a) 'cplx) X (and (math-zerop (nth 1 a)) (math-zerop (nth 2 a)))) X ((eq (car a) 'hms) X (and (math-zerop (nth 1 a)) X (math-zerop (nth 2 a)) X (math-zerop (nth 3 a))))) X (eq a 0)) X) X;;; Faster in-line version zerop, normalized values only. X(defmacro Math-zerop (a) ; [P N] X (` (if (consp (, a)) X (and (not (memq (car (, a)) '(bigpos bigneg))) X (if (eq (car (, a)) 'float) X (eq (nth 1 (, a)) 0) X (math-zerop (, a)))) X (eq (, a) 0))) X) X X(defun math-zerop-bignum (a) X (and (eq (car a) 0) X (progn X (while (eq (car (setq a (cdr a))) 0)) X (null a))) X) X X(defmacro Math-natnum-lessp (a b) X (` (if (consp (, a)) X (and (consp (, b)) X (= (math-compare-bignum (cdr (, a)) (cdr (, b))) -1)) X (or (consp (, b)) X (< (, a) (, b))))) X) X X(defmacro Math-integer-negp (a) X (` (if (consp (, a)) X (eq (car (, a)) 'bigneg) X (< (, a) 0))) X) X X(defmacro Math-integer-posp (a) X (` (if (consp (, a)) X (eq (car (, a)) 'bigpos) X (> (, a) 0))) X) X X;;; True if A is real and negative. [P n] [Public] X(defun math-negp (a) X (if (consp a) X (cond ((eq (car a) 'bigpos) nil) X ((eq (car a) 'bigneg) (cdr a)) X ((eq (car a) 'frac) X (if (Math-integer-negp (nth 2 a)) X (Math-integer-posp (nth 1 a)) X (Math-integer-negp (nth 1 a)))) X ((eq (car a) 'float) X (Math-integer-negp (nth 1 a))) X ((eq (car a) 'hms) X (if (math-zerop (nth 1 a)) X (if (math-zerop (nth 2 a)) X (math-negp (nth 3 a)) X (math-negp (nth 2 a))) X (math-negp (nth 1 a)))) X ((eq (car a) 'intv) X (or (math-negp (nth 3 a)) X (and (math-zerop (nth 3 a)) X (memq (nth 1 a) '(0 2)))))) X (< a 0)) X) X(defmacro Math-negp (a) X (` (if (consp (, a)) X (or (eq (car (, a)) 'bigneg) X (and (not (eq (car (, a)) 'bigpos)) X (if (memq (car (, a)) '(frac float)) X (Math-integer-negp (nth 1 (, a))) X (math-negp (, a))))) X (< (, a) 0))) X) X X;;; True if A is a negative number or an expression the starts with '-'. X(defun math-looks-negp (a) ; [P x] [Public] X (or (Math-negp a) X (eq (car-safe a) 'neg) X (and (memq (car-safe a) '(* /)) X (or (math-looks-negp (nth 1 a)) X (math-looks-negp (nth 2 a))))) X) X(defmacro Math-looks-negp (a) ; [P x] [Public] X (` (or (Math-negp (, a)) X (and (consp (, a)) (or (eq (car (, a)) 'neg) X (and (memq (car (, a)) '(* /)) X (or (math-looks-negp (nth 1 (, a))) X (math-looks-negp (nth 2 (, a))))))))) X) X X;;; True if A is real and positive. [P n] [Public] X(defun math-posp (a) X (if (consp a) X (cond ((eq (car a) 'bigpos) (cdr a)) X ((eq (car a) 'bigneg) nil) X ((eq (car a) 'frac) X (if (Math-integer-negp (nth 2 a)) X (Math-integer-negp (nth 1 a)) X (Math-integer-posp (nth 1 a)))) X ((eq (car a) 'float) X (Math-integer-posp (nth 1 a))) X ((eq (car a) 'hms) X (if (math-zerop (nth 1 a)) X (if (math-zerop (nth 2 a)) X (math-posp (nth 3 a)) X (math-posp (nth 2 a))) X (math-posp (nth 1 a)))) X ((eq (car a) 'mod) X (not (math-zerop (nth 1 a)))) X ((eq (car a) 'intv) X (or (math-posp (nth 2 a)) X (and (math-zerop (nth 2 a)) X (memq (nth 1 a) '(0 1)))))) X (> a 0)) X) X(defmacro Math-posp (a) X (` (if (consp (, a)) X (or (eq (car (, a)) 'bigpos) X (and (not (eq (car (, a)) 'bigneg)) X (if (memq (car (, a)) '(frac float)) X (Math-integer-posp (nth 1 (, a))) X (math-posp (, a))))) X (> (, a) 0))) X) X X;;; True if A is a small or big integer. [P x] [Public] X(defun math-integerp (a) X (or (integerp a) X (memq (car-safe a) '(bigpos bigneg))) X) X(defmacro Math-integerp (a) X (` (or (not (consp (, a))) X (memq (car (, a)) '(bigpos bigneg)))) X) X X(fset 'math-fixnump (symbol-function 'integerp)) X(fset 'math-fixnatnump (symbol-function 'natnump)) X X;;; True if A is (numerically) a non-negative integer. [P N] [Public] X(defun math-natnump (a) X (or (natnump a) X (eq (car-safe a) 'bigpos)) X) X(defmacro Math-natnump (a) X (` (if (consp (, a)) X (eq (car (, a)) 'bigpos) X (>= (, a) 0))) X) X X;;; True if A is a rational (or integer). [P x] [Public] X(defun math-ratp (a) X (or (integerp a) X (memq (car-safe a) '(bigpos bigneg frac))) X) X(defmacro Math-ratp (a) X (` (or (not (consp (, a))) X (memq (car (, a)) '(bigpos bigneg frac)))) X) X X;;; True if A is a real (or rational). [P x] [Public] X(defun math-realp (a) X (or (integerp a) X (memq (car-safe a) '(bigpos bigneg frac float))) X) X(defmacro Math-realp (a) X (` (or (not (consp (, a))) X (memq (car (, a)) '(bigpos bigneg frac float)))) X) X X;;; True if A is a real or HMS form. [P x] [Public] X(defun math-anglep (a) X (or (integerp a) X (memq (car-safe a) '(bigpos bigneg frac float hms))) X) X(defmacro Math-anglep (a) X (` (or (not (consp (, a))) X (memq (car (, a)) '(bigpos bigneg frac float hms)))) X) X X;;; True if A is a floating-point real or complex number. [P x] [Public] X(defun math-floatp (a) X (or (eq (car-safe a) 'float) X (and (memq (car-safe a) '(cplx polar mod sdev intv)) X (or (math-floatp (nth 1 a)) X (math-floatp (nth 2 a)) X (and (eq (car a) 'intv) (math-floatp (nth 3 a)))))) X) X X;;; True if A is a number of any kind. [P x] [Public] X(defun math-numberp (a) X (or (integerp a) X (memq (car-safe a) '(bigpos bigneg frac float cplx polar))) X) X(defmacro Math-numberp (a) X (` (or (not (consp (, a))) X (memq (car (, a)) '(bigpos bigneg frac float cplx polar)))) X) X X;;; True if A is a complex number or angle. [P x] [Public] X(defun math-scalarp (a) X (or (integerp a) X (memq (car-safe a) '(bigpos bigneg frac float cplx polar hms))) X) X(defmacro Math-scalarp (a) X (` (or (not (consp (, a))) X (memq (car (, a)) '(bigpos bigneg frac float cplx polar hms)))) X) X X;;; True if A is a vector. [P x] [Public] X(defun math-vectorp (a) X (eq (car-safe a) 'vec) X) X(defmacro Math-vectorp (a) X (` (and (consp (, a)) (eq (car (, a)) 'vec))) X) X X;;; True if A is a number or a vector. [P x] [Public] X(defun math-numvecp (a) X (or (Math-numberp a) X (Math-vectorp a)) X) X X;;; True if A is numerically (but not literally) an integer. [P x] [Public] X(defun math-messy-integerp (a) X (cond X ((eq (car-safe a) 'float) (>= (nth 2 a) 0)) X ((eq (car-safe a) 'frac) (Math-integerp (math-normalize a)))) X) X(defmacro Math-messy-integerp (a) X (` (and (consp (, a)) X (eq (car (, a)) 'float) X (>= (nth 2 (, a)) 0))) X) X X;;; True if A is any scalar data object. [P x] X(defun math-objectp (a) ; [Public] X (or (integerp a) X (memq (car-safe a) '(bigpos bigneg frac float cplx X polar hms sdev intv mod))) X) X(defmacro Math-objectp (a) ; [Public] X (` (or (not (consp (, a))) X (memq (car (, a)) X '(bigpos bigneg frac float cplx polar hms sdev intv mod)))) X) X X;;; True if A is any vector or scalar data object. [P x] X(defun math-objvecp (a) ; [Public] X (or (integerp a) X (memq (car-safe a) '(bigpos bigneg frac float cplx polar X hms sdev intv mod vec incomplete))) X) X(defmacro Math-objvecp (a) ; [Public] X (` (or (not (consp (, a))) X (memq (car (, a)) X '(bigpos bigneg frac float cplx polar hms sdev intv mod vec)))) X) X X X;;; True if A is an even integer. [P R R] [Public] X(defun math-evenp (a) X (if (consp a) X (and (memq (car a) '(bigpos bigneg)) X (= (% (nth 1 a) 2) 0)) X (= (% a 2) 0)) X) X X;;; Compute A / 2, for small or big integer A. [I i] X;;; If A is negative, type of truncation is undefined. X(defun math-div2 (a) X (if (consp a) X (if (cdr a) X (math-normalize (cons (car a) (math-div2-bignum (cdr a)))) X 0) X (/ a 2)) X) X X(defun math-div2-bignum (a) ; [l l] X (cond X ((null (cdr a)) (list (/ (car a) 2))) X (t (cons (+ (/ (car a) 2) (* (% (nth 1 a) 2) 500)) X (math-div2-bignum (cdr a))))) X) X X X;;; Verify that A is a complete object and return A. [x x] [Public] X(defun math-check-complete (a) X (cond ((integerp a) a) X ((eq (car-safe a) 'incomplete) X (cond ((memq (nth 1 a) '(cplx polar)) X (error "Complex number is incomplete")) X ((eq (nth 1 a) 'vec) X (error "Vector is incomplete")) X ((eq (nth 1 a) 'intv) X (error "Interval form is incomplete")) X (t (error "Object is incomplete")))) X ((consp a) a) X (t (error "Invalid data object encountered"))) X) X X;;; Reject an argument to a calculator function. [Public] X(defun math-reject-arg (&optional a p) X (calc-record-why p a) X (signal 'wrong-type-argument (and a (if p (list p a) (list a)))) X) X X X;;; Coerce A to be an integer (by truncation toward zero). [I N] [Public] X(defun math-trunc (a) X (cond ((Math-integerp a) a) X ((Math-looks-negp a) X (math-neg (math-trunc (math-neg a)))) X ((eq (car a) 'float) (math-scale-int (nth 1 a) (nth 2 a))) X ((eq (car a) 'frac) (math-quotient (nth 1 a) (nth 2 a))) X (t (calc-extensions) X (math-trunc-fancy a))) X) X(fset 'calcFunc-trunc (symbol-function 'math-trunc)) X X;;; Coerce A to be an integer (by truncation toward minus infinity). [I N] X(defun math-floor (a) ; [Public] X (cond ((Math-integerp a) a) X ((Math-messy-integerp a) (math-trunc a)) X ((Math-realp a) X (if (Math-negp a) X (math-add (math-trunc a) -1) X (math-trunc a))) X (t (calc-extensions) X (math-floor-fancy a))) X) X(fset 'calcFunc-floor (symbol-function 'math-floor)) X X X;;; Coerce integer A to be a bignum. [B S] X(defun math-bignum (a) X (if (>= a 0) X (cons 'bigpos (math-bignum-big a)) X (cons 'bigneg (math-bignum-big (- a)))) X) X X(defun math-bignum-big (a) ; [L s] X (if (= a 0) X nil X (cons (% a 1000) (math-bignum-big (/ a 1000)))) X) X X X;;; Build a normalized fraction. [R I I] X;;; (This could probably be implemented more efficiently than using the X;;; the plain gcd algorithm.) X(defun math-make-frac (num den) X (if (Math-integer-negp den) X (setq num (math-neg num) X den (math-neg den))) X (let ((gcd (math-gcd num den))) X (if (eq gcd 1) X (if (eq den 1) X num X (list 'frac num den)) X (if (equal gcd den) X (math-quotient num gcd) X (list 'frac (math-quotient num gcd) (math-quotient den gcd))))) X) X X;;; Build a normalized floating-point number. [F I S] X(defun math-make-float (mant exp) X (if (eq mant 0) X '(float 0 0) X (let* ((ldiff (- calc-internal-prec (math-numdigs mant)))) X (if (< ldiff 0) X (setq mant (math-scale-rounding mant ldiff) X exp (- exp ldiff)))) X (if (consp mant) X (let ((digs (cdr mant))) X (if (= (% (car digs) 10) 0) X (progn X (while (= (car digs) 0) X (setq digs (cdr digs) X exp (+ exp 3))) X (while (= (% (car digs) 10) 0) X (setq digs (math-div10-bignum digs) X exp (1+ exp))) X (setq mant (math-normalize (cons (car mant) digs)))))) X (while (= (% mant 10) 0) X (setq mant (/ mant 10) X exp (1+ exp)))) X (list 'float mant exp)) X) X X(defun math-div10-bignum (a) ; [l l] X (cond X ((null (cdr a)) (list (/ (car a) 10))) X (t (cons (+ (/ (car a) 10) (* (% (nth 1 a) 10) 100)) X (math-div10-bignum (cdr a))))) X) X X;;; Coerce A to be a float. [F N; V V] [Public] X(defun math-float (a) X (cond ((Math-integerp a) (math-make-float a 0)) X ((eq (car a) 'frac) (math-div (math-float (nth 1 a)) (nth 2 a))) X ((eq (car a) 'float) a) X ((memq (car a) '(cplx polar vec hms sdev intv mod)) X (cons (car a) (mapcar 'math-float (cdr a)))) X (t (math-reject-arg a 'objectp))) X) X(fset 'calcFunc-float (symbol-function 'math-float)) X X X;;; Compute the negative of A. [O O; o o] [Public] X(defmacro Math-integer-neg (a) X (` (if (consp (, a)) X (if (eq (car (, a)) 'bigpos) X (cons 'bigneg (cdr (, a))) X (cons 'bigpos (cdr (, a)))) X (- (, a)))) X) X(defun math-neg (a) X (cond ((not (consp a)) (- a)) X ((eq (car a) 'bigpos) (cons 'bigneg (cdr a))) X ((eq (car a) 'bigneg) (cons 'bigpos (cdr a))) X ((memq (car a) '(frac float)) X (list (car a) (Math-integer-neg (nth 1 a)) (nth 2 a))) X ((memq (car a) '(cplx vec hms)) X (cons (car a) (mapcar 'math-neg (cdr a)))) X (t (math-neg-fancy a))) X) X(defun calcFunc-neg (a) X (math-normalize (list 'neg a)) X) X X X;;; Compute the number of decimal digits in integer A. [S I] X(defun math-numdigs (a) X (if (consp a) X (if (cdr a) X (let* ((len (1- (length a))) X (top (nth len a))) X (+ (* len 3) (cond ((>= top 100) 0) ((>= top 10) -1) (t -2)))) X 0) X (cond ((>= a 100) (+ (math-numdigs (/ a 1000)) 3)) X ((>= a 10) 2) X ((>= a 1) 1) X ((= a 0) 0) X ((> a -10) 1) X ((> a -100) 2) X (t (math-numdigs (- a))))) X) X X;;; Multiply (with truncation toward 0) the integer A by 10^N. [I i S] X(defun math-scale-int (a n) X (cond ((= n 0) a) X ((> n 0) (math-scale-left a n)) X (t (math-normalize (math-scale-right a (- n))))) X) X X(defun math-scale-left (a n) ; [I I S] X (if (= n 0) X a X (if (consp a) X (cons (car a) (math-scale-left-bignum (cdr a) n)) X (if (>= n 3) X (if (or (>= a 1000) (<= a -1000)) X (math-scale-left (math-bignum a) n) X (math-scale-left (* a 1000) (- n 3))) X (if (= n 2) X (if (or (>= a 10000) (<= a -10000)) X (math-scale-left (math-bignum a) 2) X (* a 100)) X (if (or (>= a 100000) (<= a -100000)) X (math-scale-left (math-bignum a) 1) X (* a 10)))))) X) X X(defun math-scale-left-bignum (a n) X (if (>= n 3) X (while (>= (setq a (cons 0 a) X n (- n 3)) 3))) X (if (> n 0) X (math-mul-bignum-digit a (if (= n 2) 100 10) 0) X a) X) X X(defun math-scale-right (a n) ; [i i S] X (if (= n 0) X a X (if (consp a) X (cons (car a) (math-scale-right-bignum (cdr a) n)) X (if (<= a 0) X (if (= a 0) X 0 X (- (math-scale-right (- a) n))) X (if (>= n 3) X (while (and (> (setq a (/ a 1000)) 0) X (>= (setq n (- n 3)) 3)))) X (if (= n 2) X (/ a 100) X (if (= n 1) X (/ a 10) X a))))) X) X X(defun math-scale-right-bignum (a n) ; [L L S; l l S] X (if (>= n 3) X (setq a (nthcdr (/ n 3) a) X n (% n 3))) X (if (> n 0) X (cdr (math-mul-bignum-digit a (if (= n 2) 10 100) 0)) X a) X) X X;;; Multiply (with rounding) the integer A by 10^N. [I i S] X(defun math-scale-rounding (a n) X (cond ((>= n 0) X (math-scale-left a n)) X ((consp a) X (math-normalize X (cons (car a) X (let ((val (if (< n -3) X (math-scale-right-bignum (cdr a) (- -3 n)) X (if (= n -2) X (math-mul-bignum-digit (cdr a) 10 0) X (if (= n -1) X (math-mul-bignum-digit (cdr a) 100 0) X (cdr a)))))) ; n = -3 X (if (and val (>= (car val) 500)) X (if (cdr val) X (if (eq (car (cdr val)) 999) X (math-add-bignum (cdr val) '(1)) X (cons (1+ (car (cdr val))) (cdr (cdr val)))) X '(1)) X (cdr val)))))) X (t X (if (< a 0) X (- (math-scale-rounding (- a) n)) X (if (= n -1) X (/ (+ a 5) 10) X (/ (+ (math-scale-right a (- -1 n)) 5) 10))))) X) X X X;;; Compute the sum of A and B. [O O O] [Public] X(defun math-add (a b) X (or X (and (not (or (consp a) (consp b))) X (progn X (setq a (+ a b)) X (if (or (<= a -1000000) (>= a 1000000)) X (math-bignum a) X a))) X (and (Math-zerop a) (not (eq (car-safe a) 'mod)) X (if (and (math-floatp a) (Math-ratp b)) (math-float b) b)) X (and (Math-zerop b) (not (eq (car-safe b) 'mod)) X (if (and (math-floatp b) (Math-ratp a)) (math-float a) a)) X (and (Math-objvecp a) (Math-objvecp b) X (or X (and (Math-integerp a) (Math-integerp b) X (progn X (or (consp a) (setq a (math-bignum a))) X (or (consp b) (setq b (math-bignum b))) X (if (eq (car a) 'bigneg) X (if (eq (car b) 'bigneg) X (cons 'bigneg (math-add-bignum (cdr a) (cdr b))) X (math-normalize X (let ((diff (math-sub-bignum (cdr b) (cdr a)))) X (if (eq diff 'neg) X (cons 'bigneg (math-sub-bignum (cdr a) (cdr b))) X (cons 'bigpos diff))))) X (if (eq (car b) 'bigneg) X (math-normalize X (let ((diff (math-sub-bignum (cdr a) (cdr b)))) X (if (eq diff 'neg) X (cons 'bigneg (math-sub-bignum (cdr b) (cdr a))) X (cons 'bigpos diff)))) X (cons 'bigpos (math-add-bignum (cdr a) (cdr b))))))) X (and (Math-ratp a) (Math-ratp b) X (if (eq (car-safe a) 'frac) X (if (eq (car-safe b) 'frac) X (math-make-frac (math-add (math-mul (nth 1 a) (nth 2 b)) X (math-mul (nth 2 a) (nth 1 b))) X (math-mul (nth 2 a) (nth 2 b))) X (math-make-frac (math-add (nth 1 a) X (math-mul (nth 2 a) b)) X (nth 2 a))) X (math-make-frac (math-add (math-mul a (nth 2 b)) X (nth 1 b)) X (nth 2 b)))) X (and (Math-realp a) (Math-realp b) X (progn X (or (and (consp a) (eq (car a) 'float)) X (setq a (math-float a))) X (or (and (consp b) (eq (car b) 'float)) X (setq b (math-float b))) X (math-add-float a b))) X (and (calc-extensions) X (math-add-objects-fancy a b)))) X (and (calc-extensions) X (math-add-symb-fancy a b))) X) X(defun calcFunc-add (&rest rest) X (if rest X (let ((a (car rest))) X (while (setq rest (cdr rest)) X (setq a (list '+ a (car rest)))) X (math-normalize a)) X 0) X) X X(defun math-add-bignum (a b) ; [L L L; l l l] X (if a X (if b X (let* ((a (copy-sequence a)) (aa a) (carry nil) sum) X (while (and aa b) X (if carry X (if (< (setq sum (+ (car aa) (car b))) 999) X (progn X (setcar aa (1+ sum)) X (setq carry nil)) X (setcar aa (+ sum -999))) X (if (< (setq sum (+ (car aa) (car b))) 1000) X (setcar aa sum) X (setcar aa (+ sum -1000)) X (setq carry t))) X (setq aa (cdr aa) X b (cdr b))) X (if carry X (if b X (nconc a (math-add-bignum b '(1))) X (while (eq (car aa) 999) X (setcar aa 0) X (setq aa (cdr aa))) X (if aa X (progn X (setcar aa (1+ (car aa))) X a) X (nconc a '(1)))) X (if b X (nconc a b) X a))) X a) X b) X) X X(defun math-sub-bignum (a b) ; [l l l] X (if b X (if a X (let* ((a (copy-sequence a)) (aa a) (borrow nil) sum) X (while (and aa b) X (if borrow X (if (>= (setq diff (- (car aa) (car b))) 1) X (progn X (setcar aa (1- diff)) X (setq borrow nil)) X (setcar aa (+ diff 999))) X (if (>= (setq diff (- (car aa) (car b))) 0) X (setcar aa diff) X (setcar aa (+ diff 1000)) X (setq borrow t))) X (setq aa (cdr aa) X b (cdr b))) X (if borrow X (progn X (while (eq (car aa) 0) X (setcar aa 999) X (setq aa (cdr aa))) X (if aa X (progn X (setcar aa (1- (car aa))) X a) X 'neg)) X (while (eq (car b) 0) X (setq b (cdr b))) X (if b X 'neg X a))) X (while (eq (car b) 0) X (setq b (cdr b))) X (and b X 'neg)) X a) X) X X(defun math-add-float (a b) ; [F F F] X (let ((ediff (- (nth 2 a) (nth 2 b)))) X (if (>= ediff 0) X (if (>= ediff (+ calc-internal-prec calc-internal-prec)) X a X (math-make-float (math-add (nth 1 b) X (math-scale-int (nth 1 a) ediff)) X (nth 2 b))) X (if (>= (setq ediff (- ediff)) X (+ calc-internal-prec calc-internal-prec)) X b X (math-make-float (math-add (nth 1 a) X (math-scale-int (nth 1 b) ediff)) X (nth 2 a))))) X) X X;;; Compute the difference of A and B. [O O O] [Public] X(defun math-sub (a b) X (if (or (consp a) (consp b)) X (math-add a (math-neg b)) X (setq a (- a b)) X (if (or (<= a -1000000) (>= a 1000000)) X (math-bignum a) X a)) X) X(defun calcFunc-sub (&rest rest) X (if rest X (let ((a (car rest))) X (while (setq rest (cdr rest)) X (setq a (list '- a (car rest)))) X (math-normalize a)) X 0) X) X X(defun math-sub-float (a b) ; [F F F] X (let ((ediff (- (nth 2 a) (nth 2 b)))) X (if (>= ediff 0) X (if (>= ediff (+ calc-internal-prec calc-internal-prec)) X a X (math-make-float (math-add (Math-integer-neg (nth 1 b)) X (math-scale-int (nth 1 a) ediff)) X (nth 2 b))) X (if (>= (setq ediff (- ediff)) X (+ calc-internal-prec calc-internal-prec)) X b X (math-make-float (math-add (nth 1 a) X (Math-integer-neg X (math-scale-int (nth 1 b) ediff))) X (nth 2 a))))) X) X X X;;; Compute the product of A and B. [O O O] [Public] X(defun math-mul (a b) X (or X (and (not (consp a)) (not (consp b)) X (< a 1000) (> a -1000) (< b 1000) (> b -1000) X (* a b)) X (and (Math-zerop a) (not (eq (car-safe b) 'mod)) X (if (and (math-floatp b) (Math-ratp a)) (math-float a) a)) X (and (Math-zerop b) (not (eq (car-safe a) 'mod)) X (if (and (math-floatp a) (Math-ratp b)) (math-float b) b)) X (and (Math-objvecp a) (Math-objvecp b) X (or X (and (Math-integerp a) (Math-integerp b) X (progn X (or (consp a) (setq a (math-bignum a))) X (or (consp b) (setq b (math-bignum b))) X (math-normalize X (cons (if (eq (car a) (car b)) 'bigpos 'bigneg) X (if (cdr (cdr a)) X (if (cdr (cdr b)) X (math-mul-bignum (cdr a) (cdr b)) X (math-mul-bignum-digit (cdr a) (nth 1 b) 0)) X (math-mul-bignum-digit (cdr b) (nth 1 a) 0)))))) X (and (Math-ratp a) (Math-ratp b) X (if (eq (car-safe a) 'frac) X (if (eq (car-safe b) 'frac) X (math-make-frac (math-mul (nth 1 a) (nth 1 b)) X (math-mul (nth 2 a) (nth 2 b))) X (math-make-frac (math-mul (nth 1 a) b) X (nth 2 a))) X (math-make-frac (math-mul a (nth 1 b)) X (nth 2 b)))) X (and (Math-realp a) (Math-realp b) X (progn X (or (and (consp a) (eq (car a) 'float)) X (setq a (math-float a))) X (or (and (consp b) (eq (car b) 'float)) X (setq b (math-float b))) X (math-make-float (math-mul (nth 1 a) (nth 1 b)) X (+ (nth 2 a) (nth 2 b))))) X (and (calc-extensions) X (math-mul-objects-fancy a b)))) X (and (calc-extensions) X (math-mul-symb-fancy a b))) X) X X(defun calcFunc-mul (&rest rest) X (if rest X (let ((a (car rest))) X (while (setq rest (cdr rest)) X (setq a (list '* a (car rest)))) X (math-normalize a)) X 1) X) X X;;; Multiply digit lists A and B. [L L L; l l l] X(defun math-mul-bignum (a b) X (and a b X (let* ((sum (if (<= (car b) 1) X (if (= (car b) 0) X (list 0) X (copy-sequence a)) X (math-mul-bignum-digit a (car b) 0))) X (sump sum) c d aa prod) X (while (setq b (cdr b)) X (setq ss (setq sump (or (cdr sump) (setcdr sump (list 0)))) X d (car b) X c 0 X aa a) X (while (progn X (setcar ss (% (setq prod (+ (+ (car ss) (* (car aa) d)) X c)) 1000)) X (setq aa (cdr aa))) X (setq c (/ prod 1000) X ss (or (cdr ss) (setcdr ss (list 0))))) X (if (>= prod 1000) X (if (cdr ss) X (setcar (cdr ss) (+ (/ prod 1000) (car (cdr ss)))) X (setcdr ss (list (/ prod 1000)))))) X sum)) X) X X;;; Multiply digit list A by digit D. [L L D D; l l D D] X(defun math-mul-bignum-digit (a d c) X (and a X (if (<= d 1) X (and (= d 1) a) X (let* ((a (copy-sequence a)) (aa a) prod) X (while (progn X (setcar aa (% (setq prod (+ (* (car aa) d) c)) 1000)) X (cdr aa)) X (setq aa (cdr aa) X c (/ prod 1000))) X (if (>= prod 1000) X (setcdr aa (list (/ prod 1000)))) X a))) X) X X X;;; Compute the square of A. [O O] [Public] X(defun math-sqr (a) X (if (eq (car-safe a) 'calcFunc-sqrt) X (nth 1 a) X (math-mul a a)) X) X X X;;; Compute the integer (quotient . remainder) of A and B, which may be X;;; small or big integers. Type and consistency of truncation is undefined X;;; if A or B is negative. B must be nonzero. [I.I I I] [Public] X(defun math-idivmod (a b) X (if (eq b 0) X (math-reject-arg a "Division by zero")) X (if (or (consp a) (consp b)) X (if (and (natnump b) (< b 1000)) X (let ((res (math-div-bignum-digit (cdr a) b))) X (cons X (math-normalize (cons (car a) (car res))) X (cdr res))) X (or (consp a) (setq a (math-bignum a))) X (or (consp b) (setq b (math-bignum b))) X (let ((res (math-div-bignum (cdr a) (cdr b)))) X (cons X (math-normalize (cons (if (eq (car a) (car b)) 'bigpos 'bigneg) X (car res))) X (math-normalize (cons (car a) (cdr res)))))) X (cons (/ a b) (% a b))) X) X X(defun math-quotient (a b) ; [I I I] [Public] X (if (and (not (consp a)) (not (consp b))) X (if (= b 0) X (math-reject-arg a "Division by zero") X (/ a b)) X (if (and (natnump b) (< b 1000)) X (if (= b 0) X (math-reject-arg a "Division by zero") X (math-normalize (cons (car a) X (car (math-div-bignum-digit (cdr a) b))))) X (or (consp a) (setq a (math-bignum a))) X (or (consp b) (setq b (math-bignum b))) X (let* ((alen (1- (length a))) X (blen (1- (length b))) X (d (/ 1000 (1+ (nth (1- blen) (cdr b))))) X (res (math-div-bignum-big (math-mul-bignum-digit (cdr a) d 0) X (math-mul-bignum-digit (cdr b) d 0) X alen blen))) X (math-normalize (cons (if (eq (car a) (car b)) 'bigpos 'bigneg) X (car res)))))) X) X X(defun math-imod (a b) ; [I I I] [Public] X (if (and (not (consp a)) (not (consp b))) X (if (= b 0) X (math-reject-arg a "Division by zero") X (% a b)) X (cdr (math-idivmod a b))) X) X X;;; Divide a bignum digit list by another. [l.l l L] X;;; The following division algorithm is borrowed from Knuth vol. II, sec. 4.3.1 X(defun math-div-bignum (a b) X (if (null (cdr b)) X (let ((res (math-div-bignum-digit a (car b)))) X (cons (car res) (list (cdr res)))) X (let* ((alen (length a)) X (blen (length b)) X (d (/ 1000 (1+ (nth (1- blen) b)))) X (res (math-div-bignum-big (math-mul-bignum-digit a d 0) X (math-mul-bignum-digit b d 0) X alen blen))) X (if (= d 1) X res X (cons (car res) X (car (math-div-bignum-digit (cdr res) d)))))) X) X X;;; Divide a bignum digit list by a digit. [l.D l D] X(defun math-div-bignum-digit (a b) X (if (null a) X '(nil . 0) X (let* ((res (math-div-bignum-digit (cdr a) b)) X (num (+ (* (cdr res) 1000) (car a)))) X (cons X (cons (/ num b) (car res)) X (% num b)))) X) X X(defun math-div-bignum-big (a b alen blen) ; [l.l l L] X (if (< alen blen) X (cons nil a) X (let* ((res (math-div-bignum-big (cdr a) b (1- alen) blen)) X (num (cons (car a) (cdr res))) X (res2 (math-div-bignum-part num b blen))) X (cons X (cons (car res2) (car res)) X (cdr res2)))) X) X X(defun math-div-bignum-part (a b blen) ; a < b*1000 [D.l l L] X (let* ((num (+ (* (or (nth blen a) 0) 1000) (or (nth (1- blen) a) 0))) X (den (nth (1- blen) b)) X (guess (min (/ num den) 999))) X (math-div-bignum-try a b (math-mul-bignum-digit b guess 0) guess)) X) X X(defun math-div-bignum-try (a b c guess) ; [D.l l l D] X (let ((rem (math-sub-bignum a c))) X (if (eq rem 'neg) X (math-div-bignum-try a b (math-sub-bignum c b) (1- guess)) X (cons guess rem))) X) X X X;;; Compute the quotient of A and B. [O O N] [Public] X(defun math-div (a b) X (or X (and (Math-zerop b) X (math-reject-arg a "Division by zero")) X (and (Math-zerop a) (not (eq (car-safe b) 'mod)) X (if (and (math-floatp b) (Math-ratp a)) (math-float a) a)) X (and (Math-objvecp a) (Math-objvecp b) X (or X (and (Math-integerp a) (Math-integerp b) X (if calc-prefer-frac X (math-make-frac a b) X (let ((q (math-idivmod a b))) X (if (eq (cdr q) 0) X (car q) X (math-div-float (math-make-float a 0) X (math-make-float b 0)))))) X (and (Math-ratp a) (Math-ratp b) X (if (eq (car-safe a) 'frac) X (if (eq (car-safe b) 'frac) X (math-make-frac (math-mul (nth 1 a) (nth 2 b)) X (math-mul (nth 2 a) (nth 1 b))) X (math-make-frac (nth 1 a) X (math-mul (nth 2 a) b))) X (math-make-frac (math-mul a (nth 2 b)) X (nth 1 b)))) X (and (Math-realp a) (Math-realp b) X (progn X (or (and (consp a) (eq (car a) 'float)) X (setq a (math-float a))) X (or (and (consp b) (eq (car b) 'float)) X (setq b (math-float b))) X (math-div-float a b))) X (and (calc-extensions) X (math-div-objects-fancy a b)))) X (and (calc-extensions) X (math-div-symb-fancy a b))) X) X(defun calcFunc-div (a &rest rest) X (while rest X (setq a (list '/ a (car rest)) X rest (cdr rest))) X (math-normalize a) X) X X(defun math-div-float (a b) ; [F F F] X (let ((ldiff (max (- (1+ calc-internal-prec) X (- (math-numdigs (nth 1 a)) (math-numdigs (nth 1 b)))) SHAR_EOF echo "End of part 2" echo "File calc.el is continued in part 3" echo "3" > s2_seq_.tmp exit 0